home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istva / ISTVA.MAC.f
Encoding:
Text File  |  1989-03-04  |  43.3 KB  |  1,271 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.5
  3. C---------------------------------------------------------
  4. C YXLIB Customisation Parameters
  5. C ------------------------------
  6.  
  7. C Routine Names
  8. C -------------
  9.  
  10. C Field Definitions: Parse Tree Attributes
  11. C ----------------------------------------
  12. C Note: The high-order bit in the word (bit 31 in a 32-bit machine) MUST
  13. C       NOT BE USED, as ordinary arithmetic is used to extract some fields
  14.  
  15. C Attribute Table Macros
  16. C ----------------------
  17.  
  18. C YXLIB Bits
  19. C ----------
  20.  
  21. C YXLIB Local Record Macros
  22. C -------------------------
  23. C   type VARX = record
  24. C                   su: integer;    (* Storage units for variable *)
  25. C                   common: ^(S_COMMON) or -maxint..-1;
  26. C                                   (* ^(common block symbol), nil (0) or
  27. C                                      negative of equivalence class number *)
  28. C                   comsize: integer;(* Offset in common or equiv class *)
  29. C                   equiv: ^EQV;    (* Pointer to equivalence link *)
  30. C                   if SYMBOL(var_arr_decl)<>0 then array: ARRAYX
  31. C                                   (* array information stored here *)
  32. C               end;
  33. C
  34. C   type ARRAYX = record
  35. C                   elts: integer;  (* Number of elements in the array *)
  36. C                   dims: integer;  (* Number of dimensions of the array *)
  37. C                   limits: array [1..dims] of
  38. C                               record LOWER,UPPER: integer end
  39. C                 end;
  40.  
  41.  
  42. C   type EQH = HEAD record          (* Equivalence head record *)
  43. C                       common: ^(S_COMMON) or -maxint..-1;
  44. C                       usage: set of usage_bits
  45. C                   end;
  46.  
  47. C   type EQV = LINK record          (* Equivalence variable record (link) *)
  48. C                       sudif: integer;
  49. C                       symbol: ^(S_VAR)
  50. C                   end;
  51.  
  52. C   type LPR = record
  53. C                   glob: ^(GPU) or -^(GEX);
  54. C                   nargs: integer;
  55. C                   args: array [1..nargs] of packed record
  56. C                               dtype: min_dtype..max_dtype;
  57. C                               argument_type: atype;
  58. C                               descendents: ^HEAD;
  59. C                               if dtype=type_char then
  60. C                                   min_length, max_length: integer
  61. C                               end if
  62. C                           end record
  63. C              end;
  64.  
  65. C                                   (* Argument type definitions *)
  66. C   type ATYPE = (scalar,arelm,array,proc,label);
  67. C   const min_atype = scalar; max_atype = label;
  68.  
  69. C YXLIB Record Definition: Semi-Local
  70. C -----------------------------------
  71. C   type PAREC = LINK record
  72. C                   argnum: integer; (* Argument number passed down as *)
  73. C                   prsym: ^(S_PROC); (* Procedure passed down to *)
  74. C                   argsym: ^symbol; (* Actual argument being passed down *)
  75. C                   pusym: ^(S_PU); (* Associating program-unit (context) *)
  76. C                   stmtno: integer; (* Statement number of assoc (context) *)
  77. C                end;
  78.  
  79. C   type UNSAF = LINK record
  80. C                   code: 1..5;     (* Type of unsafe reference to be checked *)
  81. C                   argnum: integer;(* Argument number applicable *)
  82. C                   extra: anything;(* Extra data (not used by inherit_expr) *)
  83. C                   pusym: ^(S_PU); (* Context: associating program-unit *)
  84. C                   stmtno: integer;(* Context: statement number *)
  85. C                   prsym: ^(S_PROC)(* proc being called *)
  86. C                end;
  87.  
  88. C YXLIB Global Record Macros
  89. C --------------------------
  90. C
  91. C   type G_COM = record             Global common block record
  92. C                   size: integer;
  93. C                   type: (character,numeric,mixed); (* logical = numeric *)
  94. C                   save: (saved,not_saved,only_in_main);
  95. C                   init: integer   (* Number of times init'ed by block data *)
  96. C                end;
  97.  
  98. C
  99. C   type G_PU = record              Global program-unit record
  100. C                   dtype: integer;
  101. C                   chrlen: integer;
  102. C                   culist: ^HEAD;  (* common block usage list header ptr *)
  103. C                   nargs: integer;
  104. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  105. C                   entrys: ^(HEAD) record ^G_ENT end;
  106. C                   args: array [1..nargs] of gpuarg
  107. C               end;
  108.  
  109. C   type G_ENT = record
  110. C                   dtype: integer;
  111. C                   chrlen: integer;
  112. C                   pu: ^G_PU;
  113. C                   nargs: integer;
  114. C                   descend: ^HEAD; (* descendent routine list header ptr *)
  115. C                   args: array [1..nargs] of ^guparg
  116. C                end;
  117.  
  118. C type gpuarg = record
  119. C                   dtype,chlen: integer;
  120. C                   usage: (arg,read,update);
  121. C                   struc: (scal,array,proc,label);
  122. C                   size: integer;
  123. C                   pass: ^HEAD;
  124. C                   inh: ^HEAD(inherit)
  125. C               end;
  126. C type inherit = record
  127. C                   type: (proc,expr,dupl,comm,sfa,doix,arg);
  128. C                   ass: ^(GPU);    (* associating program-unit *)
  129. C                   snum: integer;  (* statement number of association *)
  130. C                   if (type=proc) then
  131. C                       gsyptr: ^(GPU)/-^(GEX)
  132. C                   else
  133. C                       extra: integer (* unsafe ref extra data *)
  134. C                   end if
  135.  
  136.  
  137. C Global Descendant Routine Types
  138. C -------------------------------
  139.  
  140. C Error Codes returned by YXLIB
  141. C -----------------------------
  142. C *****************************
  143. C *  Note:  The following macro definition should be set to the
  144. C *         maximum number of symbols expected in any single
  145. C *         program-unit.  On a virtual-memory system, it can
  146. C *         be set to the maximum number of symbols possible,
  147. C *         i.e.    "define(max_pu_syms,max_symbols)"
  148. C *
  149. C *         For non-virtual systems, this may take up too much space,
  150. C *         so make it smaller, e.g.
  151. C *                 "define(max_pu_syms,500)"
  152. C *****************************
  153. C * The following setting is in use at NAG Central Office:
  154.         PROGRAM ISTVA
  155.  
  156.         COMMON/VXSYMI/SYMIDX,NSYMS
  157.         INTEGER SYMIDX(5003),NSYMS
  158.  
  159.         COMMON/VXHEAD/HEADER,DATE,PART
  160.  
  161.         INTEGER HEADER(81),SYMPTH(81),LSTPTH(81),I,
  162.      +          YY,MMM,DD,HH,MM,SS,MILLI,ATRPTH(81),IODATR,IODSYM,
  163.      +          DATE(81),PART,IODLST
  164.  
  165.         INTEGER GETARG,OPEN,CREATE
  166.         EXTERNAL GETARG,OPEN,CREATE,ZYINSY,ZINIT,ZQUIT,ZTIME,ZTIMST,
  167.      +           REMARK,ERROR,ZYXRAB,CLOSE,ZYGSSI
  168.  
  169.         CALL ZINIT
  170.  
  171.         IF (GETARG(1,SYMPTH,81).EQ.-100) CALL NAMES(1,SYMPTH)
  172.         IF (GETARG(2,ATRPTH,81).EQ.-100) CALL NAMES(2,ATRPTH)
  173.         IF (GETARG(3,LSTPTH,81).EQ.-100) CALL NAMES(3,LSTPTH)
  174.         IF (GETARG(4,HEADER,81).EQ.-100) CALL NAMES(4,HEADER)
  175.  
  176.         IF (SYMPTH(1).EQ.45) THEN
  177.             IF (SYMPTH(2).EQ.129) SYMPTH(1)=129
  178.         END IF
  179.         IF (SYMPTH(1).NE.129) THEN
  180.             IODSYM=OPEN(SYMPTH,0)
  181.             IF (IODSYM.EQ.-1) CALL ERROR('Can''t open symbol path')
  182.         ELSE
  183.             IODSYM=-1
  184.         END IF
  185.         IODATR=OPEN(ATRPTH,0)
  186.         IF (IODATR.EQ.-1) CALL ERROR('Can''t open attribute file')
  187.         IODLST=CREATE(LSTPTH,1)
  188.         IF (IODLST.EQ.-1) CALL ERROR('Can''t create list path')
  189.  
  190.         IF (IODSYM.NE.-1) CALL ZYINSY(IODSYM)
  191.         CALL ZYXRAB(IODATR)
  192.         CALL CLOSE(IODATR)
  193.         CALL ZTIME(YY,MMM,DD,HH,MM,SS,MILLI)
  194.         CALL ZTIMST(YY,MMM,DD,HH,MM,SS,DATE)
  195.  
  196.         IF (IODSYM.NE.-1) THEN
  197.             PART=1
  198.             CALL VXSKIP(0,IODLST)
  199.             I=1
  200.  
  201.  100        CALL ZYGSSI(SYMIDX,NSYMS,I)
  202.             IF (NSYMS.NE.0) THEN
  203.                 CALL GETDAT
  204.                 CALL SRTIDX
  205.                 CALL PRINTS(IODLST)
  206.                 I=I+1
  207.                 GO TO 100
  208.             END IF
  209.         END IF
  210.  
  211.         PART=2
  212.         CALL VXSKIP(0,IODLST)
  213.  
  214.         CALL OUTPU(IODLST)
  215.         CALL OUTCOM(IODLST)
  216.         CALL OUTEXT(IODLST)
  217.  
  218.         CALL REMARK('[ISTVA Normal Termination]')
  219.         CALL ZQUIT(-2)
  220.  
  221.         END
  222. C ----------------------------------------------------------------------
  223. C
  224. C       N A M E S   -   Input names of files and so on
  225. C
  226.  
  227.         SUBROUTINE NAMES(NUMBER,STRING)
  228.         INTEGER NUMBER,STRING(81)
  229.  
  230.         INTEGER PROMPT(23,4)
  231.  
  232.         SAVE PROMPT
  233.  
  234.         INTEGER ZGTCMD
  235.         EXTERNAL ZPRMPT,ZGTCMD,ERROR
  236.  
  237. C "Input symbol table: "
  238. C "Input attribute file: "
  239. C "Output listing file: "
  240. C "Header text: "
  241.  
  242.         DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,115,
  243.      +121,109,98,111,108,32,116,97,98,108,101,58,
  244.      +32,129/,
  245.      +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,97,
  246.      +116,116,114,105,98,117,116,101,32,102,105,108,101,
  247.      +58,32,129/,
  248.      +       (PROMPT(I,3),I=1,22)/79,117,116,112,117,116,32,
  249.      +108,105,115,116,105,110,103,32,102,105,108,101,
  250.      +58,32,129/,
  251.      +       (PROMPT(I,4),I=1,14)/72,101,97,100,101,114,32,
  252.      +116,101,120,116,58,32,129/
  253.  
  254.         CALL ZPRMPT(PROMPT(1,NUMBER))
  255.         IF (ZGTCMD(STRING,0).EQ.-1) CALL ERROR('ZGTCMD failed')
  256.  
  257.         END
  258. C ----------------------------------------------------------------------
  259. C
  260. C       G E T D A T   -   Get symbol data
  261. C
  262.  
  263.         SUBROUTINE GETDAT
  264.  
  265.         COMMON/VXSYMI/SYMIDX,NSYMS
  266.         INTEGER SYMIDX(5003),NSYMS
  267.  
  268.         COMMON/VXSYMD/SYMBOL
  269.         INTEGER SYMBOL(8,5003)
  270.  
  271.         INTEGER I
  272.  
  273.         DO 100 I=1,NSYMS
  274.             CALL ZYGTSY(SYMIDX(I),SYMBOL(1,I))
  275.  100    CONTINUE
  276.  
  277.         END
  278. C ----------------------------------------------------------------------
  279. C
  280. C       S R T I D X   -   Sort symbol index
  281. C
  282. C       Sort key: Symbol type (then) Current position
  283. C                 (Current position is as sorted by name)
  284. C
  285.  
  286.         SUBROUTINE SRTIDX
  287.  
  288.         COMMON/VXSYMI/SYMIDX,NSYMS
  289.         INTEGER SYMIDX(5003),NSYMS
  290.  
  291.         COMMON/VXSYMD/SYMBOL
  292.         INTEGER SYMBOL(8,5003)
  293.  
  294.         INTEGER I,J,K,TMP(8),T,ITMP
  295.  
  296. C We will use a form of straight insertion
  297.         DO 600 I=2,NSYMS
  298.             J=I-1
  299. C while J>1 and a(i).lt.a(j) do j=j-1
  300.  100        IF (SYMBOL(1,I) .LT. SYMBOL(1,J)) THEN
  301.                 J=J-1
  302.                 IF (J.GE.1) GOTO 100
  303.             END IF
  304.             J=J+1
  305.             ITMP=SYMIDX(I)
  306.             DO 200 T=1,8
  307.                 TMP(T)=SYMBOL(T,I)
  308.  200        CONTINUE
  309.             DO 400 K=I,J+1,-1
  310.                 SYMIDX(K)=SYMIDX(K-1)
  311.                 DO 300 T=1,8
  312.                     SYMBOL(T,K)=SYMBOL(T,K-1)
  313.  300            CONTINUE
  314.  400        CONTINUE
  315.             SYMIDX(J)=ITMP
  316.             DO 500 T=1,8
  317.                 SYMBOL(T,J)=TMP(T)
  318.  500        CONTINUE
  319.  600    CONTINUE
  320.         END
  321. C ----------------------------------------------------------------------
  322. C
  323. C       P R I N T S   -   Print Symbols
  324. C
  325.  
  326.         SUBROUTINE PRINTS(IODLST)
  327.         INTEGER IODLST
  328.  
  329.         INTEGER MAXARD
  330.         PARAMETER (MAXARD=10)
  331.  
  332.         COMMON/VXSYMI/SYMIDX,NSYMS
  333.         INTEGER SYMIDX(5003),NSYMS
  334.  
  335.         COMMON/VXSYMD/SYMBOL
  336.         INTEGER SYMBOL(8,5003)
  337.  
  338.         INTEGER I,TEXT(134),RESULT(8),PLACE,OFFSET,NSUBS,
  339.      +          LIMIT(2,MAXARD),J,COMPTR,VARPTR
  340.         LOGICAL ADJP,INFP
  341.  
  342.         INTEGER ZYXCUS
  343.         EXTERNAL ZYXCUS,ZCHOUT,PUTCH,ZOBLNK,ZPTINT,ZYXGVL,
  344.      +           ZYXGCV,ZYXGAD
  345.  
  346.         I=0
  347.  100    I=I+1
  348.         IF (SYMBOL(1,I).NE.4) GOTO 100
  349.  
  350.         CALL VXSKIP(1,IODLST)
  351.         CALL ZCHOUT('Program Unit: ',IODLST)
  352.         CALL WRSNAM(I,IODLST)
  353.         IF (SYMBOL(4,I).GT.0) CALL ZCHOUT('FUNCTION',IODLST)
  354.         CALL VXSKIP(1,IODLST)
  355.         CALL WRBITS(SYMBOL(6,I),16,IODLST)
  356.  
  357.         I=1
  358.         IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS) THEN
  359.             CALL VXMESS('        Labels:',IODLST)
  360.  200        CALL ZOBLNK(12,IODLST)
  361.             CALL WRSNAM(I,IODLST)
  362.             CALL ZCHOUT(', Parse tree node ',IODLST)
  363.             CALL ZPTINT(SYMBOL(4,I),1,IODLST)
  364.             CALL VXSKIP(1,IODLST)
  365.             IF (SYMBOL(5,I).NE.0) THEN
  366.                 CALL ZOBLNK(16,IODLST)
  367.                 CALL ZCHOUT('Referenced by ',IODLST)
  368.                 CALL ZPTINT(SYMBOL(5,I),1,IODLST)
  369.                 CALL VXMESS(' GOTO statements',IODLST)
  370.             END IF
  371.             IF (SYMBOL(7,I).NE.0) THEN
  372.                 CALL ZOBLNK(16,IODLST)
  373.                 CALL ZCHOUT('Referenced by ',IODLST)
  374.                 CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  375.                 CALL VXMESS(' I/O statements (as FORMAT)',IODLST)
  376.             END IF
  377.             IF (MOD(SYMBOL(6,I),1000).NE.0) THEN
  378.                 CALL ZOBLNK(16,IODLST)
  379.                 CALL ZCHOUT('Ends ',IODLST)
  380.                 IF (MOD(SYMBOL(6,I),1000).EQ.1)
  381.      +          THEN
  382.                     CALL VXMESS('a DO loop',IODLST)
  383.                 ELSE
  384.                     CALL ZPTINT(
  385.      +MOD(SYMBOL(6,I),1000),1,IODLST)
  386.                     CALL VXMESS(' DO loops',IODLST)
  387.                 END IF
  388.             END IF
  389.             IF (SYMBOL(6,I)/1000.NE.0) THEN
  390.                 CALL ZOBLNK(16,IODLST)
  391.                 CALL ZCHOUT('Referenced by ',IODLST)
  392.                 CALL ZPTINT(SYMBOL(6,I)/1000,1,
  393.      +                      IODLST)
  394.                 CALL VXMESS(' ASSIGN statements',IODLST)
  395.             END IF
  396.             IF (SYMBOL(5,I)+SYMBOL(6,I)+
  397.      +          SYMBOL(7,I).EQ.0) THEN
  398.                 CALL ZOBLNK(16,IODLST)
  399.                 CALL VXMESS('Never referenced',IODLST)
  400.             END IF
  401.             I=I+1
  402.             IF (SYMBOL(1,I).EQ.1 .AND. I.LE.NSYMS)
  403.      +          GOTO 200
  404.         END IF
  405.         IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS) THEN
  406.             CALL VXMESS('        Common blocks:',IODLST)
  407.  300        CALL ZOBLNK(12,IODLST)
  408.             CALL WRSNAM(I,IODLST)
  409.             CALL ZCHOUT(', Size: ',IODLST)
  410.             CALL ZPTINT(SYMBOL(6,I),1,IODLST)
  411.             CALL VXSKIP(1,IODLST)
  412.             CALL ZOBLNK(16,IODLST)
  413.             COMPTR=SYMIDX(I)
  414.             J=1
  415.             CALL ZCHOUT('Items: ',IODLST)
  416.  350        CALL ZYXGCV(COMPTR,VARPTR)
  417.             CALL ZYGTSY(VARPTR,RESULT)
  418.             CALL ZYGTST(RESULT(2),TEXT)
  419.             IF (MOD(J,8).EQ.0) THEN
  420.                 CALL VXSKIP(1,IODLST)
  421.                 CALL ZOBLNK(23,IODLST)
  422.             END IF
  423.             CALL PUTLIN(TEXT,IODLST)
  424.             IF (COMPTR.NE.0) THEN
  425.                 CALL ZCHOUT(', ',IODLST)
  426.                 J=J+1
  427.                 GOTO 350
  428.             ELSE
  429.                 CALL VXSKIP(1,IODLST)
  430.             END IF
  431.             CALL ZOBLNK(16,IODLST)
  432.             CALL VXMESS('Usage:',IODLST)
  433.             CALL WRBITS(ZYXCUS(SYMIDX(I)),20,IODLST)
  434.             I=I+1
  435.             IF (SYMBOL(1,I).EQ.2 .AND. I.LE.NSYMS)
  436.      +          GOTO 300
  437.         END IF
  438.         IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS) THEN
  439.             CALL VXMESS('        Names (Usage Unknown):',IODLST)
  440.  400        CALL ZOBLNK(12,IODLST)
  441.             CALL WRSNAM(I,IODLST)
  442.             CALL VXSKIP(1,IODLST)
  443.             CALL WRBITS(SYMBOL(6,I),16,IODLST)
  444.             I=I+1
  445.             IF (SYMBOL(1,I).EQ.3 .AND. I.LE.NSYMS)
  446.      +          GOTO 400
  447.         END IF
  448. C SYMBOL(symbol_type,I) must = S_PU ... skip it
  449.         I=I+1
  450.         IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS) THEN
  451.             CALL VXMESS('        Variables:',IODLST)
  452.  500        CALL ZOBLNK(12,IODLST)
  453.             CALL WRSNAM(I,IODLST)
  454.             IF (SYMBOL(7,I).NE.0) THEN
  455.                 CALL ZYXGAD(SYMIDX(I),NSUBS,LIMIT,ADJP,INFP)
  456.                 CALL ZCHOUT('Array (',IODLST)
  457.                 DO 550 J=1,NSUBS
  458.                     IF (J.GT.1) CALL ZCHOUT(',',IODLST)
  459.                     IF (LIMIT(1,J).LE.LIMIT(2,J)) THEN
  460.                         IF (LIMIT(1,J).NE.1) THEN
  461.                             CALL ZPTINT(LIMIT(1,J),1,IODLST)
  462.                             CALL ZCHOUT(':',IODLST)
  463.                         END IF
  464.                         IF (J.EQ.NSUBS .AND. INFP) THEN
  465.                             CALL ZCHOUT('*',IODLST)
  466.                         ELSE
  467.                             CALL ZPTINT(LIMIT(2,J),1,IODLST)
  468.                         END IF
  469.                     ELSE
  470.                         CALL ZCHOUT('......',IODLST)
  471.                         IF (J.EQ.NSUBS .AND. INFP)
  472.      +                      CALL ZCHOUT(':*',IODLST)
  473.                     END IF
  474.  550            CONTINUE
  475.                 CALL ZCHOUT(')',IODLST)
  476.             END IF
  477.             CALL VXSKIP(1,IODLST)
  478.             CALL WRBITS(SYMBOL(6,I),16,IODLST)
  479.             CALL ZYXGVL(SYMIDX(I),PLACE,OFFSET)
  480.             IF (PLACE.GT.0) THEN
  481.                 CALL ZOBLNK(16,IODLST)
  482.                 CALL ZCHOUT('In common block /',IODLST)
  483.                 CALL ZYGTSY(PLACE,RESULT)
  484.                 CALL ZYGTST(RESULT(2),TEXT)
  485.                 CALL PUTLIN(TEXT,IODLST)
  486.                 CALL ZCHOUT('/, offset ',IODLST)
  487.                 CALL ZPTINT(OFFSET,1,IODLST)
  488.                 CALL VXSKIP(1,IODLST)
  489.             ELSE IF (PLACE.LT.0) THEN
  490.                 CALL ZOBLNK(16,IODLST)
  491.                 CALL ZCHOUT('Local equivalence class ',IODLST)
  492.                 CALL ZPTINT(-PLACE,1,IODLST)
  493.                 CALL ZCHOUT(', offset ',IODLST)
  494.                 CALL ZPTINT(OFFSET,1,IODLST)
  495.                 CALL VXSKIP(1,IODLST)
  496.             END IF
  497.             I=I+1
  498.             IF (SYMBOL(1,I).EQ.5 .AND. I.LE.NSYMS)
  499.      +          GOTO 500
  500.         END IF
  501.         IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS) THEN
  502.             CALL VXMESS('        Parameters:',IODLST)
  503.  600        CALL ZOBLNK(12,IODLST)
  504.             CALL WRSNAM(I,IODLST)
  505.             CALL ZCHOUT(', Definition node ',IODLST)
  506.             CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  507.             CALL VXSKIP(1,IODLST)
  508.             CALL WRBITS(SYMBOL(6,I),16,IODLST)
  509.             I=I+1
  510.             IF (SYMBOL(1,I).EQ.6 .AND. I.LE.NSYMS)
  511.      +          GOTO 600
  512.         END IF
  513.         IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS) THEN
  514.             CALL VXMESS('        Procedures:',IODLST)
  515.  700        CALL ZOBLNK(12,IODLST)
  516.             CALL WRSNAM(I,IODLST)
  517.             CALL VXSKIP(1,IODLST)
  518.             CALL WRBITS(SYMBOL(6,I),16,IODLST)
  519.             I=I+1
  520.             IF (SYMBOL(1,I).EQ.7 .AND. I.LE.NSYMS)
  521.      +          GOTO 700
  522.         END IF
  523.         IF (SYMBOL(1,I).EQ.8 .AND. I.LE.NSYMS) THEN
  524.             CALL VXMESS('        Statement Functions:',IODLST)
  525.  800        CALL ZOBLNK(12,IODLST)
  526.             CALL WRSNAM(I,IODLST)
  527.             CALL ZCHOUT(', defined at parse tree node ',IODLST)
  528.             CALL ZPTINT(SYMBOL(7,I),1,IODLST)
  529.             CALL VXSKIP(1,IODLST)
  530.             CALL WRBITS(SYMBOL(6,I),16,IODLST)
  531.             I=I+1
  532.             IF (SYMBOL(2,I).EQ.8 .AND. I.LE.NSYMS) GOTO 800
  533.         END IF
  534.         IF (SYMBOL(1,I).EQ.9 .AND. I.LE.NSYMS) THEN
  535.             CALL VXMESS('        Entry Points:',IODLST)
  536.  900        CALL ZOBLNK(12,IODLST)
  537.             CALL WRSNAM(I,IODLST)
  538.             CALL VXSKIP(1,IODLST)
  539.             CALL WRBITS(SYMBOL(6,I),16,IODLST)
  540.             I=I+1
  541.             IF (SYMBOL(2,I).EQ.9 .AND. I.LE.NSYMS)
  542.      +          GOTO 900
  543.         END IF
  544.  
  545.         END
  546. C ----------------------------------------------------------------------
  547. C
  548. C       O U T P U   -   Output Program-Unit Information
  549. C
  550.  
  551.         SUBROUTINE OUTPU(IODLST)
  552.         INTEGER IODLST
  553.  
  554. C MAXARG = Maximum number of dummy arguments in a p.u.
  555. C MAXLIN = Maximum line length to use (only affects descendent list)
  556.  
  557.         INTEGER MAXARG,MAXLIN
  558.         PARAMETER (MAXARG=60,MAXLIN=80)
  559.  
  560.         INTEGER DTYPE,CHRLEN,NARGS,ARG(7,MAXARG),I,NAME(134),CULIST,
  561.      +          CUSAGE,DESC,REFTYP,GSYPTR,ARGNUM,GPUPTR,EXTRA,ELIST,
  562.      +          EDESC,COL,LASDES
  563.  
  564.         INTEGER ZYXSU,ZIAND,LENGTH
  565.         EXTERNAL ZYXGPU,ZMESS,ERROR,ZCHOUT,ZPTINT,PUTCH,ZYXGGD,ZYXSU,
  566.      +           ZYXGPA,ZYXGIR,ZIAND,ZYXGEP,ZYXGNA,
  567.      +           ZYXGEN,LENGTH
  568.  
  569.         GPUPTR=-1
  570.         CALL VXMESS('Program Units',IODLST)
  571.         CALL VXMESS('=============',IODLST)
  572.  100    IF (GPUPTR.NE.-1) CALL VXSKIP(1,IODLST)
  573.         CALL ZCHOUT('    ',IODLST)
  574.         CALL ZYXGPU(GPUPTR,NAME,DTYPE,CHRLEN,NARGS,CULIST,DESC,ELIST,
  575.      +                ARG)
  576.         CALL WRNAME(NAME,DTYPE,CHRLEN,IODLST)
  577.         IF (DTYPE.GT.0) CALL ZCHOUT('Function',IODLST)
  578.         CALL VXSKIP(1,IODLST)
  579.         IF (NARGS.GT.MAXARG) CALL ERROR('OUTPU: Too many arguments')
  580.         IF (NARGS.EQ.0 .AND. DTYPE.NE.-3)
  581.      +      CALL VXMESS('        No arguments',IODLST)
  582.         DO 200 I=1,NARGS
  583.             CALL ZCHOUT('        Argument ',IODLST)
  584.             CALL ZPTINT(I,1,IODLST)
  585.             CALL ZCHOUT(': ',IODLST)
  586.             CALL OUTARG(ARG(1,I),12,IODLST)
  587.  200    CONTINUE
  588.  300    IF (CULIST.NE.0) THEN
  589.             CALL ZYXGCU(CULIST,GSYPTR,CUSAGE)
  590.             CALL ZYXGNA(GSYPTR,NAME)
  591.             CALL ZCHOUT('        Common Block /',IODLST)
  592.             CALL PUTLIN(NAME,IODLST)
  593.             CALL ZCHOUT('/',IODLST)
  594.             IF (ZIAND(CUSAGE,16+32+64+
  595.      +                       65536+131072).NE.0) THEN
  596.                 CALL ZCHOUT(', updated',IODLST)
  597.             END IF
  598.             CALL VXSKIP(1,IODLST)
  599.             GOTO 300
  600.         END IF
  601.         LASDES=0
  602.         COL=1
  603.  400    IF (DESC.NE.0) THEN
  604.             CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
  605.             IF (REFTYP.EQ.1 .OR. REFTYP.EQ.2) THEN
  606.                 CALL ZYXGNA(GSYPTR,NAME)
  607.                 IF (LASDES.NE.1 .AND. LASDES.NE.2)
  608.      +          THEN
  609.                     IF (COL.NE.1) CALL VXSKIP(1,IODLST)
  610.                     CALL ZCHOUT('        Calls ',IODLST)
  611.                     COL=15
  612.                 ELSE
  613.                     CALL ZCHOUT(', ',IODLST)
  614.                     COL=COL+2
  615.                     IF (COL+LENGTH(NAME).GE.MAXLIN) THEN
  616.                         CALL VXSKIP(1,IODLST)
  617.                         CALL ZOBLNK(14,IODLST)
  618.                         COL=15
  619.                     END IF
  620.                 END IF
  621.                 LASDES=REFTYP
  622.                 CALL PUTLIN(NAME,IODLST)
  623.                 COL=COL+LENGTH(NAME)
  624.             ELSE IF (REFTYP.EQ.3 .OR. REFTYP.EQ.4)
  625.      +      THEN
  626.                 IF (LASDES.NE.0) THEN
  627.                     LASDES=0
  628.                     CALL VXSKIP(1,IODLST)
  629.                 END IF
  630.                 CALL ZYXGNA(GSYPTR,NAME)
  631.                 CALL ZCHOUT('        ',IODLST)
  632.                 CALL PUTLIN(NAME,IODLST)
  633.                 CALL VXMESS(' passed out (as an actual argument)',
  634.      +                      IODLST)
  635.             ELSE IF (REFTYP.EQ.5) THEN
  636.                 IF (LASDES.NE.0) THEN
  637.                     LASDES=0
  638.                     CALL VXSKIP(1,IODLST)
  639.                     COL=1
  640.                 END IF
  641.                 CALL ZCHOUT('        Calls argument ',IODLST)
  642.                 CALL ZPTINT(ARGNUM,1,IODLST)
  643.                 CALL VXSKIP(1,IODLST)
  644.             ELSE IF (REFTYP.EQ.6) THEN
  645.                 IF (LASDES.NE.0) THEN
  646.                     LASDES=0
  647.                     CALL VXSKIP(1,IODLST)
  648.                     COL=1
  649.                 END IF
  650.                 CALL ZCHOUT('        Argument ',IODLST)
  651.                 CALL ZPTINT(ARGNUM,1,IODLST)
  652.                 CALL VXMESS(' passed out (as an actual argument)',
  653.      +                      IODLST)
  654.             ELSE
  655.                 IF (LASDES.NE.0) THEN
  656.                     LASDES=0
  657.                     CALL VXSKIP(1,IODLST)
  658.                     COL=1
  659.                 END IF
  660.                 CALL ZCHOUT('        ??Unknown descendent type ',IODLST)
  661.                 CALL ZPTINT(ARGNUM,1,IODLST)
  662.                 CALL VXSKIP(1,IODLST)
  663.             END IF
  664.             GOTO 400
  665.         ELSE IF (COL.NE.1) THEN
  666.             CALL VXSKIP(1,IODLST)
  667.         END IF
  668.  500    IF (ELIST.NE.0) THEN
  669.             CALL ZYXGEP(ELIST,GSYPTR)
  670.             CALL ZYXGEN(GSYPTR,NAME,DTYPE,CHRLEN,NARGS,EXTRA,EDESC,
  671.      +                       ARG)
  672.             CALL ZCHOUT('        ENTRY Point ',IODLST)
  673.             CALL PUTLIN(NAME,IODLST)
  674.             IF (DTYPE.NE.-1) THEN
  675.                 CALL ZCHOUT(', ',IODLST)
  676.                 CALL WRTYPE(DTYPE,CHRLEN,.TRUE.,IODLST)
  677.             END IF
  678.             CALL VXSKIP(1,IODLST)
  679.             IF (NARGS.EQ.0)
  680.      +          CALL VXMESS('             No arguments',IODLST)
  681.             DO 600 I=1,NARGS
  682.                 CALL ZCHOUT('            Argument ',IODLST)
  683.                 CALL ZPTINT(I,1,IODLST)
  684.                 CALL ZCHOUT(': ',IODLST)
  685.                 CALL OUTARG(ARG(1,I),16,IODLST)
  686.  600        CONTINUE
  687.  700        IF (EDESC.NE.0) THEN
  688.                 CALL ZYXGGD(EDESC,REFTYP,GSYPTR,ARGNUM)
  689.                 IF (REFTYP.EQ.1 .OR. REFTYP.EQ.2)
  690.      +          THEN
  691.                     CALL ZYXGNA(GSYPTR,NAME)
  692.                     CALL ZCHOUT('            ENTRY point calls ',IODLST)
  693.                     CALL PUTLIN(NAME,IODLST)
  694.                     CALL VXSKIP(1,IODLST)
  695.                 ELSE IF (REFTYP.EQ.3 .OR.
  696.      +                   REFTYP.EQ.4) THEN
  697.                     CALL ZYXGNA(GSYPTR,NAME)
  698.                     CALL ZCHOUT('            ',IODLST)
  699.                     CALL PUTLIN(NAME,IODLST)
  700.                     CALL VXMESS(
  701.      +' passed out from ENTRY (as an actual argument)',IODLST)
  702.                 ELSE IF (REFTYP.EQ.5) THEN
  703.                     CALL ZCHOUT(
  704.      +'            ENTRY point calls argument ',IODLST)
  705.                     CALL ZPTINT(ARGNUM,1,IODLST)
  706.                     CALL VXSKIP(1,IODLST)
  707.                 ELSE IF (REFTYP.EQ.6) THEN
  708.                     CALL ZCHOUT('            Argument ',IODLST)
  709.                     CALL ZPTINT(ARGNUM,1,IODLST)
  710.                     CALL VXMESS(' passed out (as an actual argument)',
  711.      +                         IODLST)
  712.                 ELSE
  713.                     CALL ZCHOUT('            ?Unknown descendent type ',
  714.      +                          IODLST)
  715.                     CALL ZPTINT(REFTYP,1,IODLST)
  716.                     CALL VXSKIP(1,IODLST)
  717.                 END IF
  718.                 GOTO 700
  719.             END IF
  720.             GOTO 500
  721.         END IF
  722.  800    IF (DESC.NE.0) THEN
  723.             CALL ZYXGGD(DESC,REFTYP,GSYPTR,ARGNUM)
  724.             IF (REFTYP.EQ.1 .OR. REFTYP.EQ.2) THEN
  725.                 CALL ZYXGNA(GSYPTR,NAME)
  726.                 CALL ZCHOUT('        Calls ',IODLST)
  727.                 CALL PUTLIN(NAME,IODLST)
  728.                 CALL VXSKIP(1,IODLST)
  729.             ELSE IF (REFTYP.EQ.3 .OR. REFTYP.EQ.4)
  730.      +      THEN
  731.                 CALL ZYXGNA(GSYPTR,NAME)
  732.                 CALL ZCHOUT('        ',IODLST)
  733.                 CALL PUTLIN(NAME,IODLST)
  734.                 CALL VXMESS(' passed out (as an actual argument)',
  735.      +                      IODLST)
  736.             ELSE IF (REFTYP.EQ.5) THEN
  737.                 CALL ZCHOUT('        Calls argument ',IODLST)
  738.                 CALL ZPTINT(ARGNUM,1,IODLST)
  739.                 CALL VXSKIP(1,IODLST)
  740.             ELSE IF (REFTYP.EQ.6) THEN
  741.                 CALL ZCHOUT('        Argument ',IODLST)
  742.                 CALL ZPTINT(ARGNUM,1,IODLST)
  743.                 CALL VXMESS(' passed out (as an actual argument)',
  744.      +                      IODLST)
  745.             ELSE
  746.                 CALL ZCHOUT('        ??Unknown descendent type ',IODLST)
  747.                 CALL ZPTINT(ARGNUM,1,IODLST)
  748.                 CALL VXSKIP(1,IODLST)
  749.             END IF
  750.             GOTO 800
  751.         END IF
  752.         IF (GPUPTR.GT.0) GOTO 100
  753.         CALL VXSKIP(1,IODLST)
  754.  
  755.         END
  756. C ----------------------------------------------------------------------
  757. C
  758. C       O U T A R G   -   Output (pu) argument data
  759. C
  760.  
  761.         SUBROUTINE OUTARG(GPUARG,TABPOS,IODLST)
  762.         INTEGER GPUARG(7),TABPOS,IODLST
  763.  
  764.         INTEGER ARGNUM,DESREC,REFTYP,GSYPTR,NAME(134),INHTYP,ASSOC,
  765.      +          STMTNO,EXTRA
  766.         LOGICAL WRAP
  767.  
  768.         INTEGER ZYXSU
  769.         EXTERNAL ZYXSU,ZYXGPA,ZYXGGD,ZYXGNA,ZYXGIR,
  770.      +           ZCHOUT,ZPTINT,PUTCH,PUTLIN,ZMESS,ZOBLNK
  771.  
  772.         CALL WRTYPE(GPUARG(1+0),GPUARG(1+1),
  773.      +              .TRUE.,IODLST)
  774.         WRAP=.FALSE.
  775.         IF (GPUARG(4).EQ.2) THEN
  776.             IF (GPUARG(1+0).NE.-1)
  777.      +          CALL ZCHOUT(' function',IODLST)
  778.         ELSE IF (GPUARG(1+2).EQ.1) THEN
  779.             CALL ZCHOUT(', re'//'ad-only',IODLST)
  780.         ELSE IF (GPUARG(1+2).EQ.2) THEN
  781.             CALL ZCHOUT(', update',IODLST)
  782.         ELSE
  783.             CALL ZCHOUT(', argument to external subprogram',IODLST)
  784.             WRAP=.TRUE.
  785.         END IF
  786.         IF (GPUARG(1+3).EQ.1 .AND.
  787.      +      GPUARG(1+4).EQ.0 .AND.
  788.      +      (GPUARG(1+0).NE.6 .OR.
  789.      +      GPUARG(1+1).NE.0)) THEN
  790.             CALL ZCHOUT(', ',IODLST)
  791.             IF (WRAP) THEN
  792.                 CALL PUTCH(10,IODLST)
  793.                 CALL ZOBLNK(TABPOS,IODLST)
  794.             END IF
  795.             CALL ZCHOUT('assumed-size/adjustable array',IODLST)
  796.         ELSE IF (GPUARG(1+3).EQ.1) THEN
  797.             CALL ZCHOUT(', ',IODLST)
  798.             IF (WRAP) THEN
  799.                 CALL PUTCH(10,IODLST)
  800.                 CALL ZOBLNK(TABPOS,IODLST)
  801.             END IF
  802.             CALL ZCHOUT('array (',IODLST)
  803.             IF (GPUARG(1+1).EQ.0) THEN
  804.                 CALL ZPTINT(GPUARG(1+4)/
  805.      +                      ZYXSU(GPUARG(1+0)),1,IODLST)
  806.             ELSE
  807.                 CALL ZPTINT(GPUARG(1+4)/
  808.      +                      GPUARG(1+1),1,IODLST)
  809.             END IF
  810.             CALL ZCHOUT(' elements)',IODLST)
  811.         END IF
  812.         CALL VXSKIP(1,IODLST)
  813.         IF (GPUARG(1+5).NE.0) THEN
  814.  100        CALL ZYXGPA(GPUARG(1+5),ARGNUM,DESREC)
  815.             CALL ZOBLNK(TABPOS,IODLST)
  816.             CALL ZCHOUT('passed as argument ',IODLST)
  817.             CALL ZPTINT(ARGNUM,1,IODLST)
  818.             CALL ZCHOUT(' to ',IODLST)
  819.             CALL ZYXGGD(DESREC,REFTYP,GSYPTR,ARGNUM)
  820.             IF (REFTYP.EQ.5) THEN
  821.                 CALL ZCHOUT('argument ',IODLST)
  822.                 CALL ZPTINT(ARGNUM,1,IODLST)
  823.             ELSE
  824.                 CALL ZYXGNA(GSYPTR,NAME)
  825.                 CALL PUTLIN(NAME,IODLST)
  826.             END IF
  827.             CALL VXSKIP(1,IODLST)
  828.             IF (GPUARG(1+5).NE.0) GOTO 100
  829.         END IF
  830.         IF (GPUARG(1+6).NE.0) THEN
  831.             CALL ZOBLNK(TABPOS,IODLST)
  832.             CALL ZCHOUT('Actual arguments: ',IODLST)
  833.  200        CALL ZYXGIR(GPUARG(1+6),INHTYP,ASSOC,STMTNO,
  834.      +                        EXTRA)
  835.             IF (INHTYP.EQ.0) THEN
  836.                 CALL ZCHOUT('procedure ',IODLST)
  837.                 CALL ZYXGNA(ABS(EXTRA),NAME)
  838.                 CALL PUTLIN(NAME,IODLST)
  839.             ELSE IF (INHTYP.EQ.1) THEN
  840.                 CALL ZCHOUT('expression',IODLST)
  841.             ELSE IF (INHTYP.EQ.3) THEN
  842.                 CALL ZCHOUT('argument from common /',IODLST)
  843.                 CALL ZYXGNA(ABS(EXTRA),NAME)
  844.                 CALL PUTLIN(NAME,IODLST)
  845.                 CALL ZCHOUT('/',IODLST)
  846.             ELSE IF (INHTYP.EQ.2) THEN
  847.                 CALL ZCHOUT('duplicate of argument ',IODLST)
  848.                 CALL ZPTINT(EXTRA,1,IODLST)
  849.             ELSE IF (INHTYP.EQ.4) THEN
  850.                 CALL ZCHOUT('statement fn dummy argument',
  851.      +                      IODLST)
  852.             ELSE IF (INHTYP.EQ.5) THEN
  853.                 CALL ZCHOUT('DO-loop index',IODLST)
  854.             ELSE
  855.                 CALL ZCHOUT('***UNKNOWN***',IODLST)
  856.             END IF
  857.             CALL ZCHOUT(' (from ',IODLST)
  858.             CALL ZYXGNA(ASSOC,NAME)
  859.             CALL PUTLIN(NAME,IODLST)
  860.             CALL ZCHOUT(', statement ',IODLST)
  861.             CALL ZPTINT(STMTNO,1,IODLST)
  862.             CALL VXMESS(')',IODLST)
  863.             IF (GPUARG(1+6).NE.0) THEN
  864.                 CALL ZOBLNK(TABPOS+18,IODLST)
  865.                 GOTO 200
  866.             END IF
  867.         END IF
  868.  
  869.         END
  870. C ----------------------------------------------------------------------
  871. C
  872. C       O U T C O M   -   Output common block information
  873. C
  874.  
  875.         SUBROUTINE OUTCOM(IODLST)
  876.         INTEGER IODLST
  877.  
  878.         INTEGER COMLEN,COMTYP,TEXT(134),BLANK(8),COMSAV,COMINI,GCBPTR
  879.  
  880.         SAVE BLANK
  881.  
  882.         INTEGER EQUAL
  883.         EXTERNAL ZYXGCB,ZMESS,PUTCH,ZCHOUT,PUTLIN,EQUAL
  884.  
  885.         DATA BLANK/36,67,79,77,77,79,78,129/
  886.  
  887.         GCBPTR=-1
  888.         CALL ZYXGCB(GCBPTR,TEXT,COMLEN,COMTYP,COMSAV,COMINI)
  889.         CALL VXMESS('Common Blocks',IODLST)
  890.         CALL VXMESS('=============',IODLST)
  891.         IF (GCBPTR.GE.0) THEN
  892.  100        CALL ZCHOUT('    ',IODLST)
  893.             CALL PUTCH(47,IODLST)
  894.             IF (EQUAL(TEXT,BLANK).EQ.-3) CALL PUTLIN(TEXT,IODLST)
  895.             CALL ZCHOUT('/, Length ',IODLST)
  896.             CALL ZPTINT(COMLEN,1,IODLST)
  897.             IF (COMTYP.EQ.0) THEN
  898.                 CALL ZCHOUT(', character',IODLST)
  899.             ELSE IF (COMTYP.EQ.1) THEN
  900.                 CALL ZCHOUT(', non-character',IODLST)
  901.             ELSE IF (COMTYP.EQ.2) THEN
  902.                 CALL ZCHOUT(', mixed (ch'//'ar & other)',IODLST)
  903.             ELSE
  904.                 CALL ZCHOUT(', BAD VALUE FOR COMTYP',IODLST)
  905.             END IF
  906.             IF (COMSAV.EQ.2) THEN
  907.                 CALL ZCHOUT(', only occurs in main program',IODLST)
  908.             ELSE IF (COMSAV.EQ.1) THEN
  909.                 CALL ZCHOUT(', SAVEd in subprograms',IODLST)
  910.             END IF
  911.             IF (COMINI.EQ.1) THEN
  912.                 CALL VXMESS(', initialised by BLOCK DATA',IODLST)
  913.             ELSE IF (COMINI.GT.1) THEN
  914.                 CALL ZCHOUT(', occurs in ',IODLST)
  915.                 CALL ZPTINT(COMINI,1,IODLST)
  916.                 CALL VXMESS(' BLOCK DATA subprograms',IODLST)
  917.             ELSE
  918.                 CALL VXSKIP(1,IODLST)
  919.             END IF
  920.             IF (GCBPTR.NE.0) THEN
  921.                 CALL ZYXGCB(GCBPTR,TEXT,COMLEN,COMTYP,COMSAV,COMINI)
  922.                 GOTO 100
  923.             END IF
  924.         ELSE
  925.             CALL VXMESS('    There are n'//'o common blocks...',IODLST)
  926.         END IF
  927.         CALL VXSKIP(1,IODLST)
  928.  
  929.         END
  930. C ----------------------------------------------------------------------
  931. C
  932. C       O U T E X T   -   Output external references
  933. C
  934.  
  935.         SUBROUTINE OUTEXT(IODLST)
  936.         INTEGER IODLST
  937.  
  938.         INTEGER MAXARG
  939.         PARAMETER (MAXARG=60)
  940. C This parameter also appears in SUBROUTINE OUTPU
  941.  
  942.         INTEGER NAME(134),DTYPE,CHRLEN,NARGS,ARGBLK(MAXARG*3),I,J,B,
  943.      +          GEXPTR,INHX,ASSOC,INHTYP,STMTNO,EXTRA
  944.         CHARACTER*13 ATYPE(0:4)
  945.  
  946.         SAVE USAGE
  947.  
  948.         EXTERNAL ZYXGEX,ZMESS,ZCHOUT,ZPTINT,ZYXGIR
  949.  
  950.         DATA ATYPE/'Scalar.      ',
  951.      +             'Array element',
  952.      +             'Array.       ',
  953.      +             'Function.    ',
  954.      +             'Label.       '/
  955.  
  956.         GEXPTR=-1
  957.         CALL ZYXGEX(GEXPTR,NAME,DTYPE,CHRLEN,NARGS,ARGBLK)
  958.         IF (GEXPTR.GE.0) THEN
  959.             CALL VXMESS('External References',IODLST)
  960.             CALL VXMESS('===================',IODLST)
  961.  100        CALL ZCHOUT('    ',IODLST)
  962.             CALL WRNAME(NAME,DTYPE,CHRLEN,IODLST)
  963.             IF (DTYPE.GT.0) CALL ZCHOUT('Function ',IODLST)
  964.             CALL VXSKIP(1,IODLST)
  965.             IF (NARGS.GT.MAXARG) CALL ERROR('OUTEXT: Too many args')
  966.             IF (NARGS.EQ.0) CALL VXMESS('        No arguments',IODLST)
  967.             IF (NARGS.LT.0) CALL VXMESS('        Only passed as arg',
  968.      +                                 IODLST)
  969.             J=1
  970.             DO 200 I=1,NARGS
  971.                 B=MOD(ARGBLK(J+0),8)
  972.                 CALL ZCHOUT('        Argument ',IODLST)
  973.                 CALL ZPTINT(I,1,IODLST)
  974.                 CALL ZCHOUT(': ',IODLST)
  975.                 DTYPE=ARGBLK(J+0)/8+(-3)
  976.                 INHX=ARGBLK(J+1)
  977.                 IF (DTYPE.EQ.6) THEN
  978.                     CALL WRTYPE(DTYPE,ARGBLK(J+2),.TRUE.,IODLST)
  979.                     IF (ARGBLK(J+2).NE.ARGBLK(J+3)
  980.      +                  .AND. ARGBLK(J+2).NE.0) THEN
  981.                         CALL ZCHOUT('......(',IODLST)
  982.                         CALL ZPTINT(ARGBLK(J+3),1,IODLST)
  983.                         CALL ZCHOUT(') ',IODLST)
  984.                     END IF
  985.                     J=J+4
  986.                 ELSE
  987.                     CALL WRTYPE(DTYPE,0,.TRUE.,IODLST)
  988.                     J=J+2
  989.                 END IF
  990.                 IF (DTYPE.NE.10 .AND. DTYPE.NE.-1) THEN
  991.                     CALL VXMESS(ATYPE(B),IODLST)
  992.                 ELSE
  993.                     CALL VXSKIP(1,IODLST)
  994.                 END IF
  995.                 IF (INHX.NE.0) THEN
  996.                     CALL ZCHOUT('            Actual arguments: ',IODLST)
  997.  150                CALL ZYXGIR(INHX,INHTYP,ASSOC,STMTNO,EXTRA)
  998.                     IF (INHTYP.EQ.0) THEN
  999.                         CALL ZCHOUT('procedure ',IODLST)
  1000.                         CALL ZYXGNA(ABS(EXTRA),NAME)
  1001.                         CALL PUTLIN(NAME,IODLST)
  1002.                     ELSE IF (INHTYP.EQ.1) THEN
  1003.                         CALL ZCHOUT('expression',IODLST)
  1004.                     ELSE IF (INHTYP.EQ.3) THEN
  1005.                         CALL ZCHOUT('argument from common /',IODLST)
  1006.                         CALL ZYXGNA(ABS(EXTRA),NAME)
  1007.                         CALL PUTLIN(NAME,IODLST)
  1008.                         CALL ZCHOUT('/',IODLST)
  1009.                     ELSE IF (INHTYP.EQ.2) THEN
  1010.                         CALL ZCHOUT('duplicate of argument ',IODLST)
  1011.                         CALL ZPTINT(EXTRA,1,IODLST)
  1012.                     ELSE IF (INHTYP.EQ.4) THEN
  1013.                         CALL ZCHOUT('statement fn dummy argument',
  1014.      +                              IODLST)
  1015.                     ELSE IF (INHTYP.EQ.5) THEN
  1016.                         CALL ZCHOUT('DO-loop index',IODLST)
  1017.                     ELSE
  1018.                         CALL ZCHOUT('***UNKNOWN***',IODLST)
  1019.                     END IF
  1020.                     CALL ZCHOUT(' (from ',IODLST)
  1021.                     CALL ZYXGNA(ASSOC,NAME)
  1022.                     CALL PUTLIN(NAME,IODLST)
  1023.                     CALL ZCHOUT(', statement ',IODLST)
  1024.                     CALL ZPTINT(STMTNO,1,IODLST)
  1025.                     CALL VXMESS(')',IODLST)
  1026.                     IF (INHX.NE.0) THEN
  1027.                         CALL ZCHOUT('                              ',
  1028.      +                              IODLST)
  1029.                         GOTO 150
  1030.                     END IF
  1031.                 END IF
  1032.  200        CONTINUE
  1033.             IF (GEXPTR.GT.0) THEN
  1034.                 CALL ZYXGEX(GEXPTR,NAME,DTYPE,CHRLEN,NARGS,ARGBLK)
  1035.                 GOTO 100
  1036.             END IF
  1037.         ELSE
  1038.             CALL VXMESS('There are n'//'o external references...',
  1039.      +                  IODLST)
  1040.         END IF
  1041.  
  1042.         END
  1043. C ----------------------------------------------------------------------
  1044. C
  1045. C       W R S N A M   -   Write symbol name and data type if any
  1046. C
  1047.  
  1048.         SUBROUTINE WRSNAM(N,IODLST)
  1049.         INTEGER N,IODLST
  1050.  
  1051.         COMMON/VXSYMI/SYMIDX,NSYMS
  1052.         INTEGER SYMIDX(5003),NSYMS
  1053.  
  1054.         COMMON/VXSYMD/SYMBOL
  1055.         INTEGER SYMBOL(8,5003)
  1056.  
  1057.         INTEGER TEXT(134)
  1058.  
  1059.         EXTERNAL ZYGTST,PUTLIN,ZCHOUT,PUTCH,ZPTINT
  1060.  
  1061.         CALL ZYGTST(SYMBOL(2,N),TEXT)
  1062.         CALL PUTLIN(TEXT,IODLST)
  1063.         IF (SYMBOL(1,N).EQ.2 .OR.
  1064.      +      SYMBOL(1,N).EQ.1) RETURN
  1065.         CALL PUTCH(32,IODLST)
  1066.         CALL WRTYPE(SYMBOL(4,N),SYMBOL(5,N),.FALSE.,
  1067.      +              IODLST)
  1068.         CALL PUTCH(32,IODLST)
  1069.  
  1070.         END
  1071. C ----------------------------------------------------------------------
  1072. C
  1073. C       W R T Y P E   -   Write data type
  1074. C
  1075.  
  1076.         SUBROUTINE WRTYPE(DTYPE,CHRLEN,GLOBAL,IODLST)
  1077.         INTEGER DTYPE,CHRLEN,IODLST
  1078.         LOGICAL GLOBAL
  1079.  
  1080.         CHARACTER*17 TYPTXT(-3:15)
  1081.  
  1082.         SAVE TYPTXT
  1083.  
  1084.         EXTERNAL ZCHOUT,PUTCH,ZPTINT
  1085.  
  1086.         DATA TYPTXT/
  1087.      +'PROGRAM.         ',
  1088.      +'BLOCK DATA.      ',
  1089.      +'SUBROUTINE.      ',
  1090.      +'*** UNKNOWN ***. ',
  1091.      +'INTEGER.         ',
  1092.      +'REAL.            ',
  1093.      +'LOGICAL.         ',
  1094.      +'COMPLEX.         ',
  1095.      +'DOUBLE PRECISION.',
  1096.      +'CHARACTER.       ',
  1097.      +'DOUBLE COMPLEX.  ',
  1098.      +'Generic.         ',
  1099.      +'Hollerith.       ',
  1100.      +'Label.           ',
  1101.      +'Substring spec...',
  1102.      +'LOGICAL*1.       ',
  1103.      +'LOGICAL*2.       ',
  1104.      +'INTEGER*2.       ',
  1105.      +'REAL*16.         '/
  1106.  
  1107.         CALL ZCHOUT(TYPTXT(DTYPE),IODLST)
  1108.         IF (CHRLEN.NE.0) THEN
  1109.             CALL PUTCH(42,IODLST)
  1110.             IF (CHRLEN.GT.0) THEN
  1111.                 CALL ZPTINT(CHRLEN,1,IODLST)
  1112.             ELSE IF (GLOBAL) THEN
  1113.                 CALL ERROR('Global charlen 60 than zero')
  1114.             ELSE
  1115.                 CALL ZCHOUT('(Node ',IODLST)
  1116.                 CALL ZPTINT(-CHRLEN,1,IODLST)
  1117.                 CALL ZCHOUT(')',IODLST)
  1118.             END IF
  1119.         ELSE IF (GLOBAL .AND. DTYPE.EQ.6) THEN
  1120.             CALL ZCHOUT('*(*)',IODLST)
  1121.         END IF
  1122.         CALL PUTCH(32,IODLST)
  1123.  
  1124.         END
  1125. C ----------------------------------------------------------------------
  1126. C
  1127. C       W R N A M E   -   Write a (global) name and data type
  1128. C
  1129.  
  1130.         SUBROUTINE WRNAME(NAME,DTYPE,CHRLEN,IODLST)
  1131.         INTEGER NAME(*),DTYPE,CHRLEN,IODLST
  1132.  
  1133.         EXTERNAL PUTLIN,ZCHOUT
  1134.  
  1135.         CALL PUTLIN(NAME,IODLST)
  1136.         IF (NAME(1).EQ.129) CALL ZCHOUT('Indirect reference',IODLST)
  1137.         CALL ZCHOUT(': ',IODLST)
  1138.         CALL WRTYPE(DTYPE,CHRLEN,.TRUE.,IODLST)
  1139.  
  1140.         END
  1141. C ----------------------------------------------------------------------
  1142. C
  1143. C       W R B I T S   -   Write meaning of attribute bits
  1144. C
  1145.  
  1146.         SUBROUTINE WRBITS(BITS,TAB,IODLST)
  1147.         INTEGER BITS,TAB,IODLST
  1148.  
  1149.         INTEGER NBITS
  1150.         PARAMETER (NBITS=23)
  1151.  
  1152.         INTEGER I
  1153.         CHARACTER*34 BITTXT(NBITS)
  1154.  
  1155.         SAVE BITTXT
  1156.  
  1157.         INTEGER ZIAND
  1158.         EXTERNAL ZMESS,ZIAND,ZOBLNK
  1159.  
  1160.         DATA (BITTXT(I),I=1,19)/
  1161.      +'Declared EXTERNAL.                ',
  1162.      +'Declared INTRINSIC.               ',
  1163.      +'Formal parameter.                 ',
  1164.      +'Explicitly typed.                 ',
  1165.      +'In ASSIGN statement.              ',
  1166.      +'Assigned to on left of "=".       ',
  1167.      +'In READ input list.               ',
  1168.      +'In DATA statement.                ',
  1169.      +'Statement function formal param.  ',
  1170.      +'In EQUIVALENCE statement.         ',
  1171.      +'In COMMON statement.              ',
  1172.      +'Used as an actual argument.       ',
  1173.      +'Standard intrinsic function.      ',
  1174.      +'Called as a function.             ',
  1175.      +'In an expression.                 ',
  1176.      +'Called as a subroutine.           ',
  1177.      +'Used as a DO-loop index.          ',
  1178.      +'Actual argument to external.      ',
  1179.      +'Parameter value known.            '/
  1180.         DATA (BITTXT(I),I=20,NBITS)/
  1181.      +'Equivalenced into a common block. ',
  1182.      +'In an array declarator.           ',
  1183.      +'In INCLUDE file.                  ',
  1184.      +'Type declaration has been seen.   '/
  1185.  
  1186.         DO 100 I=1,NBITS
  1187.             IF (ZIAND(BITS,1).NE.0) THEN
  1188.                 CALL ZOBLNK(TAB,IODLST)
  1189.                 CALL VXMESS(BITTXT(I),IODLST)
  1190.             END IF
  1191.             BITS=BITS/2
  1192.  100    CONTINUE
  1193.  
  1194.         END
  1195. C ----------------------------------------------------------------------
  1196. C
  1197. C       V X S K I P   -   Skip lines on output file
  1198. C
  1199.  
  1200.         SUBROUTINE VXSKIP(N,IODLST)
  1201.         INTEGER N,IODLST
  1202.  
  1203.         INTEGER LPP,MARGIN,TOPMAR
  1204.         PARAMETER (LPP=72,MARGIN=6,TOPMAR=4)
  1205.  
  1206.         COMMON/VXHEAD/HEADER,DATE,PART
  1207.         INTEGER HEADER(81),DATE(81),PART
  1208.  
  1209.         INTEGER I,LINENO
  1210.  
  1211.         SAVE LINENO
  1212.  
  1213.         DATA LINENO/0/
  1214.  
  1215. C (N.EQ.0) => Page eject now
  1216.         IF (N.EQ.0 .AND. LINENO.NE.0) THEN
  1217.             DO 100 I=LINENO,LPP
  1218.                 CALL PUTCH(10,IODLST)
  1219.  100        CONTINUE
  1220.             LINENO=0
  1221.         END IF
  1222.  
  1223. C (LINENO.EQ.0) => at top of page
  1224.         IF (LINENO.EQ.0) THEN
  1225. C First, output top margin
  1226.             DO 200 I=1,TOPMAR
  1227.                 CALL PUTCH(10,IODLST)
  1228.  200        CONTINUE
  1229.             LINENO=TOPMAR+1
  1230. C Now, output header
  1231.             CALL PUTLIN(HEADER,IODLST)
  1232.             IF (PART.EQ.1) THEN
  1233.                 CALL ZCHOUT(': Extended Symbol Table Listing, ',IODLST)
  1234.             ELSE
  1235.                 CALL ZCHOUT(': Global Attribute Listing, ',IODLST)
  1236.             END IF
  1237.             CALL PUTLIN(DATE,IODLST)
  1238.             CALL PUTCH(10,IODLST)
  1239.             CALL PUTCH(10,IODLST)
  1240.             LINENO=LINENO+2
  1241.         END IF
  1242. C Ok, now output the blank lines (but not further than the end of page)
  1243.         DO 300 I=1,MIN(N,LPP-LINENO)
  1244.             CALL PUTCH(10,IODLST)
  1245.  300    CONTINUE
  1246.         LINENO=LINENO+MIN(N,LPP-LINENO)
  1247. C If this brings us into the bottom margin, skip to top of page
  1248.         IF (LINENO.GT.LPP-MARGIN) THEN
  1249.             DO 400 I=LINENO,LPP
  1250.                 CALL PUTCH(10,IODLST)
  1251.  400        CONTINUE
  1252.             LINENO=0
  1253.         END IF
  1254.  
  1255.         END
  1256. C ----------------------------------------------------------------------
  1257. C
  1258. C       V X M E S S   -   Write message to output file
  1259. C
  1260.  
  1261.         SUBROUTINE VXMESS(STRING,IODLST)
  1262.         CHARACTER*(*) STRING
  1263.         INTEGER IODLST
  1264.  
  1265.         EXTERNAL ZCHOUT
  1266.  
  1267.         CALL ZCHOUT(STRING,IODLST)
  1268.         CALL VXSKIP(1,IODLST)
  1269.  
  1270.         END
  1271.